home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
0769B.ZIP
/
DBF2MEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-05-10
|
23KB
|
883 lines
{$C-}
{ Turbo Pascal program to copy dBASE III Char fields TO Memo files }
{ By J. Troutman 74746,1567 5/8/85 }
{ minor revisions 5/3/86 to allow proper access to dBASE III Plus files}
PROGRAM CharToMemo;
(* This program will copy designated character fields to a designated
Memo field. This was one of my early attempts at a Turbo Pascal
program, so the code is rather rough at places. However, it does
show how to access both .DBF files and .DBT files.
See DBF.PAS for some (slightly) more polished routines for
accessing .DBF files. *)
CONST
VER = '1.01';
{Revised to fix incompatibility with dBASE III Plus files }
{ Start of Include file: GetStrng.pas}
(* GetStrng is a routine I used to use to validate user input. There are
several better routines for doing this in DL 1. See EDIT.PAS (the one
with uploaded with PPN [76703,3015] for a good example. *)
{---------------------------------------------------------------------------}
TYPE
Str80 = STRING[80];
ValidChar = SET OF Char;
PROCEDURE PutMessage(Message : Str80);
VAR
X, Y, L : Byte;
BEGIN
X := WhereX;
Y := WhereY;
L := Length(Message);
IF L = 0 THEN
BEGIN
GoToXY(1, 25);
ClrEol;
END
ELSE
BEGIN
GoToXY(((80-L) DIV 2), 25);
Write(Message);
END;
GoToXY(X, Y);
END;
FUNCTION GetStrng(Valid : ValidChar;
InputLen, Row, Col : Byte;
Shift : Boolean) : Str80;
CONST
ErrorMessage : Str80 = 'Invalid key! Please try again.';
VAR
Key : Char;
Len : Byte;
Mask,Temp : Str80;
KeyError : Boolean;
BEGIN
Temp := '';
KeyError := False;
Len := 1;
FillChar(Mask,SizeOf(Mask),$B0);
Mask[0] := Chr(InputLen);
GoToXY(Col, Row);
Write(Mask);
GoToXY(Col, Row);
Read(Kbd, Key);
WHILE Key <> ^M DO
BEGIN
IF Shift THEN Key := UpCase(Key);
IF (Key IN Valid) AND (Len <= InputLen) THEN
BEGIN
Temp := Temp+Key;
Len := Succ(Len);
Write(Key);
IF KeyError THEN
BEGIN
PutMessage('');
KeyError := False;
END;
END
ELSE
BEGIN
IF (Key = ^H) AND (Len <> 1) THEN
BEGIN
Len := Len-1;
Write(^H+'_'+^H);
Delete(Temp, Len, 1);
IF KeyError THEN
BEGIN
PutMessage('');
KeyError := False;
END;
END
ELSE
IF Key <> ^M THEN
BEGIN
KeyError := True;
PutMessage(ErrorMessage);
END;
END;
IF (InputLen = 1) AND (Len = 2) THEN
Key := ^M
ELSE
Read(Kbd, Key);
END;
GetStrng := Temp;
IF KeyError THEN PutMessage('');
END;
{---------------------------------------------------------------------------}
{ End of Include File GetStrng.pas }
CONST
BUFFSIZE = 25599; { counting from 0 }
MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit }
BYTES_IN_FILE_RECORD = 128; { Turbo BlockRead/Write default record }
BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }
TYPE
HeaderType = ARRAY[0..31] OF Byte; { dBASE III header }
FieldType = ARRAY[0..31] OF Byte; { dBASE III field definitions }
DBFRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte;
Str255 = STRING[255];
Str10 = STRING[10];
BufferType = ARRAY[0..BUFFSIZE] OF Byte; { buffer for Block I/O }
FileType = FILE;
FieldRecord = RECORD
Name : Str10;
Typ : Char;
Len : Byte;
Dec : Byte;
Off : Integer;
END;
FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF FieldRecord;
MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
MemoFile = FILE OF MemoRecord;
ChoiceArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF Integer;
ByteFile = FILE OF Byte;
VAR
InFile, OutFile : FILE;
InBuffer, OutBuffer : BufferType;
Header : HeaderType;
FieldDesc : FieldType;
Fields : FieldArray;
DataRecord : DBFRecord;
RemainingRecs : Real;
NextMemo : Real;
EndFile, FinalWrite : Boolean;
NumberOfRecs : Real;
MemoBuffer : MemoRecord;
InMemo, OutMemo : MemoFile;
CharChoice : ChoiceArray;
LogicChoice, MemoChoice : Integer;
Semicolon : Boolean;
FUNCTION CheckKey : Boolean; { returns True if ^C pressed, False on }
{ any other key, pauses screen on ^S }
VAR
Key : Char;
BEGIN
Read(Kbd, Key);
CASE Key OF
^C : CheckKey := True;
^S : BEGIN
Key := Chr(0);
WHILE Key <> ^S DO Read(Kbd, Key);
CheckKey := False;
END;
ELSE
CheckKey := False;
END;
END;
PROCEDURE PutB(VAR F : FileType;
VAR Buffer : BufferType;
B : Byte);
CONST
Recs : Integer = 25600;
I : Integer = 0;
BEGIN
IF FinalWrite THEN
BEGIN
Recs := I;
IF Recs <> 0 THEN BlockWrite(F, Buffer, Recs);
END
ELSE
BEGIN
Buffer[I] := B;
I := Succ(I);
IF I = Recs THEN
BEGIN
I := 0;
BlockWrite(F, Buffer, Recs);
END;
END;
END;
FUNCTION GetB(VAR F : FileType;
VAR Buffer : BufferType;
VAR B : Byte) : Byte;
CONST
EndOfReads : Boolean = False;
Recs : Integer = 25600;
I : Integer = 25600;
BEGIN
IF (I = Recs) AND NOT EndOfReads THEN
BEGIN
I := 0;
IF RemainingRecs < Recs THEN Recs := Trunc(RemainingRecs);
{$I-} BlockRead(F, Buffer, Recs); {$I+}
IF IOResult <> 0 THEN EndOfReads := True;
RemainingRecs := RemainingRecs-Recs;
IF RemainingRecs = 0 THEN EndOfReads := True;
END;
B := Buffer[I];
GetB := B;
I := Succ(I);
IF EndOfReads AND (Succ(I) = Recs)
THEN EndFile := True;
END;
FUNCTION CopyByte(VAR InFile, OutFile : FileType;
VAR InBuffer, OutBuffer : BufferType;
VAR B : Byte) : Byte;
BEGIN
PutB(OutFile, OutBuffer, GetB(InFile, InBuffer, B));
CopyByte := B;
END;
PROCEDURE TootYourHorn;
BEGIN
NoSound;
Sound(440); Delay(250); NoSound; Delay(20);
Sound(440); Delay(250); NoSound; Delay(20);
Sound(440); Delay(250); NoSound; Delay(20);
Sound(352); Delay(1000); NoSound;
END;
FUNCTION OpenFile(VAR F : FileType; FileName : Str80) : Integer;
BEGIN
Assign(F, FileName);
{$I-} Reset(F,1); {$I+} {the '1' parameter sets the record size}
OpenFile := IOResult;
END;
PROCEDURE CloseFiles;
BEGIN
PutB(OutFile, OutBuffer, 26);
FinalWrite := True;
PutB(OutFile, OutBuffer, 26);
Close(OutFile);
Close(InFile);
Close(OutMemo);
Close(InMemo);
Halt;
END;
PROCEDURE HeaderError;
BEGIN
WriteLn;
WriteLn('Database Header has been compromised.');
WriteLn('I guess you will need someone better than I to fix this file!');
CloseFiles;
END;
PROCEDURE Pause;
BEGIN
WriteLn;
WriteLn('Press any key to continue . . .(^C to abort)');
IF CheckKey THEN CloseFiles;
END;
PROCEDURE DisplayStructure(VAR FieldDesc : FieldType;
VAR Field : FieldRecord);
VAR
I : Integer;
CONST
Offset : Integer = 1; {Offset of field within record }
BEGIN
WITH Field DO
BEGIN
I := 0;
Name := ' ';
REPEAT
Name[Succ(I)] := Chr(FieldDesc[I]);
I := Succ(I);
UNTIL FieldDesc[I] = 0;
Typ := Char(FieldDesc[11]);
Len := FieldDesc[16];
Dec := FieldDesc[17];
Off := Offset;
Offset := Offset+Len;
Write('. ', Name, ' ', Typ, ' ', Len:3);
IF Typ = 'N' THEN Write(' ', Dec:2);
IF NOT(Typ IN ['C', 'N', 'L', 'M', 'D']) THEN HeaderError;
END;
END;
PROCEDURE DisplayFields(VAR Fields : FieldArray;
FieldCount : Integer;
FTyp : Char);
VAR
I, R, C : Integer;
S : Str80;
BEGIN
CASE FTyp OF
'C' : S := 'Select one or more Character fields to convert to a Memo';
'L' : S := 'Select a Logical field to indicate Memo presence';
'M' : S := 'Select the destination Memo field';
END;
I := (80-Length(S)) DIV 2;
Window(1, 1, 80, 25); ClrScr; GoToXY(1, 1);
TextBackground(Yellow); TextColor(Blue); ClrEol;
GoToXY(I, 1); Write(S);
TextBackground(Blue); TextColor(Yellow);
Window(1, 2, 80, 25); GoToXY(1, 1);
R := 1; C := 1; I := 1;
WHILE I <= FieldCount DO
BEGIN
WITH Fields[I] DO
BEGIN
IF Typ = FTyp THEN
BEGIN
GoToXY(C, R);
Write(I:2, ' ', Name);
R := Succ(R);
IF R = 20 THEN C := C+15;
IF C > 70 THEN BEGIN C := 1; Pause; ClrScr; END;
END;
END;
I := Succ(I);
END;
END;
FUNCTION GetField(FieldCount : Integer; S : Str80) : Integer;
CONST
Valid : ValidChar = ['0'..'9'];
VAR
I, Code : Integer;
Done : Boolean;
Response : Str80;
BEGIN
Window(1, 1, 80, 25);
Done := False;
WHILE NOT Done DO
BEGIN
GoToXY(1, 22); Write(S); I := Length(S)+1;
Response := GetStrng(Valid, 3, 22, I, False);
Val(Response, I, Code);
IF (Code = 0) AND (I IN [0..FieldCount]) THEN
BEGIN
GetField := I;
Done := True;
END
ELSE
BEGIN
GoToXY(10, 25);
Write('Must be 0..', FieldCount:3);
END;
END;
END;
PROCEDURE SelectFields(VAR Fields : FieldArray;
FieldCount : Integer);
VAR
I, R, C, Code : Integer;
Done, FinallyDone : Boolean;
Response : Str80;
Ch : Char;
BEGIN
FinallyDone := False;
WHILE NOT FinallyDone DO BEGIN
DisplayFields(Fields, FieldCount, 'C');
Window(1, 22, 80, 25);
ClrScr;
I := 1; C := 1;
Done := False;
WHILE NOT Done DO
BEGIN
CharChoice[I] := GetField(FieldCount, 'Select Character fields:');
IF CharChoice[I] = 0 THEN
Done := True
ELSE IF Fields[CharChoice[I]].Typ = 'C' THEN
BEGIN
GoToXY(C, 24);
Write(CharChoice[I]:2, ',');
C := C+3;
I := Succ(I);
END;
END;
Window(1, 1, 80, 25);
ClrScr;
I := 1;
GoToXY(1, 1);
WriteLn('The character fields you have chosen are:');
WHILE CharChoice[I] <> 0 DO
BEGIN
WriteLn(CharChoice[I]:2, ' ', Fields[CharChoice[I]].Name);
I := Succ(I);
END;
WriteLn('Are these fields correct? (Y/N)');
Read(Kbd, Ch);
IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
END;
FinallyDone := False;
WHILE NOT FinallyDone DO BEGIN
DisplayFields(Fields, FieldCount, 'L');
GoToXY(20, 20);
Write('Choose one Logic field (not mandatory)');
Window(1, 22, 80, 25);
ClrScr;
Done := False;
WHILE NOT Done DO
BEGIN
LogicChoice := GetField(FieldCount, 'Select a Logic field:');
IF LogicChoice = 0 THEN
Done := True
ELSE IF Fields[LogicChoice].Typ = 'L' THEN
BEGIN
Done := True;
END;
END;
Window(1, 1, 80, 25);
ClrScr;
GoToXY(1, 1);
IF LogicChoice > 0 THEN
BEGIN
WriteLn('The Logic field you have chosen is:');
WriteLn(LogicChoice:2, ' ', Fields[LogicChoice].Name);
END
ELSE
WriteLn('You have chosen no logic field.');
WriteLn;
WriteLn('Is this correct? (Y/N)');
Read(Kbd, Ch);
IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
END;
FinallyDone := False;
WHILE NOT FinallyDone DO BEGIN
DisplayFields(Fields, FieldCount, 'M');
GoToXY(20, 20);
Write('Choose one Memo field ');
Window(1, 22, 80, 25);
ClrScr;
Done := False;
WHILE NOT Done DO
BEGIN
MemoChoice := GetField(FieldCount, 'Select a Memo field:');
IF MemoChoice = 0 THEN
BEGIN
GoToXY(40, 23);
Write('Must choose a Memo field');
END
ELSE IF Fields[MemoChoice].Typ = 'M' THEN
Done := True;
END;
Window(1, 1, 80, 25);
ClrScr;
GoToXY(1, 1);
WriteLn('The Memo field you have chosen is:');
WriteLn(MemoChoice:2, ' ', Fields[MemoChoice].Name);
WriteLn;
WriteLn('Is this correct? (Y/N)');
Read(Kbd, Ch);
IF UpCase(Ch) = 'Y' THEN FinallyDone := True;
END;
END; {FinallyFinallyDone!}
PROCEDURE DisplayHeader(VAR Header : HeaderType;
VAR RecordLength : Integer;
VAR HeaderLength : Integer);
BEGIN
WriteLn;
WriteLn('Date of last update: ', Header[2], '/', Header[3], '/', Header[1]);
NumberOfRecs := (Header[4]*1)+
(Header[5]*256)+
(Header[6]*65536.0)+
(Header[7]*16777216.0);
WriteLn('Number of Records: ', NumberOfRecs:10:0);
HeaderLength := Header[8]+(256*Header[9]);
RecordLength := Header[10]+(256*Header[11]);
END;
PROCEDURE ReadMemo(VAR M : MemoFile;
VAR MemoBuffer : MemoRecord;
Ptr : Real);
BEGIN
LongSeek(M, Ptr);
Read(M, MemoBuffer);
END;
PROCEDURE WriteMemo(VAR M : MemoFile;
VAR MemoBuffer : MemoRecord;
Ptr : Real);
BEGIN
LongSeek(M, Ptr);
Write(M, MemoBuffer);
FillChar(MemoBuffer, 512, #0);
END;
FUNCTION GetNextMemoPointer(VAR M : MemoFile) : Real;
VAR
MBuff : MemoRecord;
BEGIN
ReadMemo(M, MBuff, 0);
GetNextMemoPointer := MBuff[1]*1.+
MBuff[2]*256.+
MBuff[3]*65536.+
MBuff[4]*16777216.;
END;
PROCEDURE PutM(VAR I : Integer; B : Integer);
BEGIN
MemoBuffer[I] := B;
I := Succ(I);
IF (I > 512) OR (B = 26) THEN
BEGIN
I := 1;
WriteMemo(OutMemo, MemoBuffer, NextMemo);
NextMemo := NextMemo+1;
END;
END;
PROCEDURE PutMemo(VAR Memo : Str255);
CONST
I : Integer = 1;
C : Integer = 1;
VAR
J, M : Integer;
PROCEDURE EndOfLine;
BEGIN
PutM(I, $8D);
PutM(I, $0A);
C := 1;
END;
BEGIN
M := Length(Memo);
IF M <> 0 THEN
BEGIN
IF Memo = Chr(26) THEN
BEGIN
PutM(I, 26);
C := 1;
END
ELSE
BEGIN
Memo := Memo+'*';
J := 1;
WHILE J <= M DO
BEGIN
IF C >= 65 THEN
IF ((Memo[J] = ' ') AND (Memo[Succ(J)] <> ' '))
OR (C >= 78) THEN EndOfLine;
IF (Memo[J] = ';') AND (Semicolon) THEN
EndOfLine
ELSE
BEGIN PutM(I, Ord(Memo[J])); C := Succ(C); END;
J := Succ(J);
END;
END;
END;
END;
PROCEDURE PutNextMemoPointer(VAR M : MemoFile; R : Real);
VAR
MBuff : MemoRecord;
BEGIN
FillChar(MBuff, 512, #0);
MBuff[4] := Trunc(R/16777216.0);
R := R-(MBuff[4]*16777216.0);
MBuff[3] := Trunc(R/65536.0);
R := R-(MBuff[3]*65536.0);
MBuff[2] := Trunc(R/256);
R := R-(MBuff[2]*256);
MBuff[1] := Trunc(R);
WriteMemo(M, MBuff, 0);
END;
VAR
RecordLength, FieldCount : Integer;
PROCEDURE CopyOneRecord;
VAR
I, J, M, L : Integer;
B : Byte;
Memo : Str255;
ThisMemo : Real;
MemoPointer : Str10;
MemoEntered : Boolean;
PROCEDURE GetARecord;
BEGIN
I := 0;
WHILE (I < RecordLength) AND (NOT EndFile) DO
BEGIN
DataRecord[I] := GetB(InFile, InBuffer, B);
I := Succ(I);
END;
END;
PROCEDURE PutARecord;
BEGIN
I := 0;
WHILE (I < RecordLength) DO
BEGIN
B := DataRecord[I];
PutB(OutFile, OutBuffer, B);
I := Succ(I);
END;
END;
BEGIN
ThisMemo := NextMemo;
GetARecord;
I := 1; MemoEntered := False;
WHILE CharChoice[I] <> 0 DO
BEGIN
WITH Fields[CharChoice[I]] DO
BEGIN
L := 1; Memo := ''; M := 0; J := Off;
WHILE L <= Len DO
BEGIN
B := DataRecord[J];
Memo := Memo+Chr(B);
IF B <> 32 THEN M := L;
L := Succ(L); J := Succ(J);
END;
IF M > 0 THEN
BEGIN
Memo[0] := Chr(M);
Memo := Memo+' ';
MemoEntered := True;
WriteLn(Name, ' ', Memo);
PutMemo(Memo);
END;
END;
I := Succ(I);
END;
IF MemoEntered THEN
BEGIN
Memo := Chr(26);
PutMemo(Memo);
END;
IF LogicChoice <> 0 THEN
BEGIN
IF MemoEntered THEN
B := $59 {'Y'}
ELSE
B := $4E; {'N'}
DataRecord[Fields[LogicChoice].Off] := B;
END;
IF MemoEntered THEN
Str(ThisMemo:10:0, MemoPointer)
ELSE
Str(0:10, MemoPointer);
J := Fields[MemoChoice].Off;
FOR I := 1 TO 10 DO
BEGIN
DataRecord[J] := Ord(MemoPointer[I]);
J := Succ(J);
END;
PutARecord;
END;
PROCEDURE SignOn;
BEGIN
ClrScr; GoToXY(10, 10);
WriteLn('CTOM -- a program to convert Char fields TO');
GoToXY(20, 11); WriteLn('dBASE III Memo files (.DBT).');
GoToXY(30, 13); WriteLn('Ver. ', VER);
GoToXY(28, 15); WriteLn('by J. Troutman');
GoToXY(20, 17); WriteLn('Ctrl-S Pauses -- Ctrl-C Aborts');
GoToXY(1, 22); Pause;
END;
VAR
Found, Break : Boolean;
HeaderLength, I, ByteCount : Integer;
Col, Row : Integer;
B : Byte;
R, RecordCount : Real;
InFileName, OutFileName, Response : Str80;
CONST
ValidFileName :
ValidChar = ['!', '#'..')', '-', '0'..'9', '@'..'Z', '_', '`', '{', '}', '~'];
YesNo : ValidChar = ['Y', 'N'];
BEGIN { CharacterTOMemo }
EndFile := False; FinalWrite := False;
Break := False; Found := False; ByteCount := 0;
TextBackground(Blue);
TextColor(Yellow);
SignOn; ClrScr;
GoToXY(1, 5);
Write('Enter Source File Name (.DBF extension assumed): ');
WHILE NOT Found DO
BEGIN
InFileName := GetStrng(ValidFileName, 8, 5, 50, True)+'.DBF';
IF OpenFile(InFile, InFileName) <> 0 THEN
BEGIN
GoToXY(1, 7);
WriteLn('I cannot seem to find ', InFileName, '.');
WriteLn('Could you run it by me again?');
Pause; Window(1, 6, 80, 25); ClrScr; Window(1, 1, 80, 25);
END
ELSE Found := True;
END;
RemainingRecs := LongFileSize(InFile);
GoToXY(1, 7);
WriteLn('There are ', RemainingRecs:7:0, ' bytes in ', InFileName, '.');
Found := False;
GoToXY(1, 10);
Write('Enter Destination File Name (.DBF assumed): ');
WHILE NOT Found DO
BEGIN
OutFileName := GetStrng(ValidFileName, 8, 10, 45, True)+'.DBF';
GoToXY(1, 12);
IF InFileName = OutFileName THEN
Write('Sorry, but both files may not have the same name.')
ELSE
Found := True;
END;
Assign(OutFile, OutFileName);
Rewrite(OutFile,1);
I := Length(InFileName);
InFileName[I] := 'T';
Assign(InMemo, InFileName);
{$I-} Reset(InMemo); {$I-}
IF IOResult <> 0 THEN BEGIN WriteLn('Cannot find memo file'); Halt; END;
I := Length(OutFileName);
OutFileName[I] := 'T';
Assign(OutMemo, OutFileName);
Rewrite(OutMemo);
WriteLn(Output, 'Reading Header Data');
I := 0;
WHILE I < 32 DO BEGIN
Header[I] := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
I := Succ(I);
ByteCount := Succ(ByteCount);
END;
WriteLn;
DisplayHeader(Header, RecordLength, HeaderLength);
Pause;
FieldCount := 0; Row := 1; Col := 1; ClrScr; GoToXY(Col, Row);
Write(' # Field Name Type Length Decimal');
Col := 41; GoToXY(Col, Row);
Write(' # Field Name Type Length Decimal');
Window(1, 2, 80, 25); Col := 1; ClrScr;
WHILE GetB(InFile, InBuffer, B) <> $0D DO
BEGIN
ByteCount := Succ(ByteCount);
IF ByteCount > HeaderLength THEN HeaderError;
I := 0;
FieldDesc[I] := B;
PutB(OutFile, OutBuffer, FieldDesc[I]);
REPEAT
I := Succ(I);
FieldDesc[I] := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
ByteCount := Succ(ByteCount);
UNTIL I = 31;
FieldCount := Succ(FieldCount);
GoToXY(Col, Row); Write(FieldCount:2);
DisplayStructure(FieldDesc, Fields[FieldCount]);
Row := FieldCount MOD 22+1;
IF Row = 1 THEN
IF Col = 41 THEN
BEGIN
Col := 1;
GoToXY(1, 22);
Pause;
ClrScr;
END
ELSE
Col := 41;
IF KeyPressed THEN IF CheckKey THEN CloseFiles;
END; {WHILE GetB(InFile, InBuffer, B) <> $0D}
PutB(OutFile, OutBuffer, B); { the $0D byte }
GoToXY(1, 22);
ByteCount := Succ(ByteCount);
Write(' Total Length: ', RecordLength:4);
{The original dBASE III files inserted a NUL character after the $0D at the
end of the header before the data began; Plus does not have this NUL
character. The following IF statement tests for the presence of the NUL.}
IF InBuffer[Succ(ByteCount)] = 0 THEN
BEGIN
B := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
ByteCount := Succ(ByteCount);
END;
GoToXY(41, 22);
Write('HeaderLength = ', HeaderLength);
{ After a dBASE file has been dConverted from II to III, there is frequently
some muck left in the header until the file has been USEd in dBASE. The
following IF statement checks for the muck. }
IF HeaderLength > ByteCount THEN
WHILE ByteCount < HeaderLength DO
BEGIN
B := CopyByte(InFile, OutFile, InBuffer, OutBuffer, B);
ByteCount := Succ(ByteCount);
END;
Pause;
SelectFields(Fields, FieldCount);
Window(1, 1, 80, 25); ClrScr; GoToXY(1, 10);
Write('Do you want semicolons converted to soft carriage returns?');
Response := GetStrng(YesNo, 1, 10, 60, True);
IF Response = 'Y' THEN Semicolon := True ELSE Semicolon := False;
NextMemo := GetNextMemoPointer(InMemo);
R := 0;
WHILE R < NextMemo DO
BEGIN
ReadMemo(InMemo, MemoBuffer, R);
WriteMemo(OutMemo, MemoBuffer, R);
R := R+1;
END;
RecordCount := 0; Window(1, 1, 80, 25); ClrScr; GoToXY(1, 25);
TextBackground(Yellow); TextColor(Blue); ClrEol;
GoToXY(15, 25); Write('Ctrl-S to Pause Ctrl-Break or Ctrl-C to abort');
TextBackground(Blue); TextColor(Yellow);
Window(1, 1, 80, 4); GoToXY(1, 2);
Write('Record Number: 1 of ', NumberOfRecs:10:0);
Write(' Next Memo Pointer:', NextMemo:10:0);
WHILE (NOT EndFile) AND (NOT Break) AND (RecordCount < NumberOfRecs) DO
BEGIN
RecordCount := RecordCount+1;
Window(1, 1, 80, 4);
GoToXY(15, 2); Write(RecordCount:10:0);
GoToXY(60, 2); Write(NextMemo:10:0);
Window(1, 5, 80, 24); ClrScr; GoToXY(1, 1);
CopyOneRecord;
PutNextMemoPointer(OutMemo, NextMemo);
IF KeyPressed THEN Break := CheckKey;
END;
TootYourHorn;
CloseFiles;
END.